PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/shazam.exe/GSTRING.IMP

Text File | 1992-09-01 | 36.0 KB | 1,033 lines

   {*******************************************************************

   GSTRING.IMP

   *******************************************************************}
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

                              *** TEXT ***

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   BLANK - TRUE if blank or WhiteSpace

   ===================================================================}
function IsBlank ( S : string ) : boolean ;
var
   x                         : byte ;
begin
   IsBlank                   := FALSE ;
   for x := 1 to length ( S ) do
      if S [ x ] <> #32 then EXIT ;
   IsBlank                   := TRUE ;
end ;
   {===================================================================

   DUP - Return string of length "Len" of char "Ch"

   ===================================================================}
function StrDup ( Ch : char ; len : byte ) : string ;
var
   S                         : string ;
begin
   FillChar ( S [ 1 ] , 255 , Ch ) ;
   S [ 0 ]                   := chr ( len ) ;
   StrDup                    := S ;
end ;
   {===================================================================

   CASE (to upper)

   ===================================================================}
function StrUpCase ( S : string ) : string ;
var
   b                         : byte ;
begin
   for b := 1 to length ( S ) do
      S [ b ]                := UpCase ( S [ b ] ) ;
   StrUpCase                 := S ;
end ;
   {===================================================================

   CASE (to lower)

   ===================================================================}
function LoCase ( Ch : char ) : char ;
begin
   if Ch in [ 'A'..'Z' ] then
      LoCase                 := Chr ( Ord ( Ch ) + 32 )
   else
      LoCase                 := Ch ;
end ;
   {===================================================================

   CASE (to lower)

   ===================================================================}
function StrLoCase ( S : string ) : string ;
var
   x                         : byte ;
begin
   for x := 1 to length ( S ) do
      S [ x ]                := LoCase ( S [ x ] ) ;
   StrLoCase                 := S ;
end ;
   {===================================================================

   CAPITALS - 1st letter only

   ===================================================================}
function Capitalize ( S : string ) : string ;
var
   x                         : byte ;
begin
   Capitalize                := S ;
   for x := 1 to length ( S ) do
      if S [ x ] in [ 'a'..'z' , 'A'..'Z' ] then
      begin
         S [ x ]             := UpCase ( S [ x ] ) ;
         Capitalize          := S ;
         EXIT ;
      end ;
end ;
   {===================================================================

   CAPITAL - all words (after each non-alpha)

   ===================================================================}
function InitialCaps ( S : string ) : string ;
var
   DoCap                     : boolean ;
   x                         : byte ;
begin
   DoCap                     := S [ 1 ] in [ 'a'..'z' , 'A'..'Z' ] ;
   for x := 1 to length ( S ) do
   begin
      if DoCap then
      begin
         S [ x ]             := UpCase ( S [ x ] ) ;
         DoCap               := FALSE ;
      end ;
      if not ( S [ x ] in [ 'a'..'z' , 'A'..'Z' ] ) then
         DoCap               := TRUE ;
   end ;
   InitialCaps               := S ;
end ;
   {===================================================================

   PAD - increase to length "Len" with leading chars

   ===================================================================}
function PadLeft ( S : string ; Ch : char ; Len : byte ) : string ;
begin
   while length ( S ) < len do
      S                      := Ch + S ;
   PadLeft                   := S ;
end ;
   {===================================================================

   PAD - increase to length "Len" with trailing chars

   ===================================================================}
function PadRight ( S : string ; Ch : char ; Len : byte ) : string ;
begin
   while length ( S ) < len do
      S                      := S + Ch ;
   PadRight                  := S ;
end ;
   {===================================================================

   PUT - add leading chars

   ===================================================================}
function PutLeft ( S : string ; Ch : char ; Count : byte ) : string ;
begin
   PutLeft                   := StrDup ( Ch , Count ) + S ;
end ;
   {===================================================================

   PUT - add trailing chars

   ===================================================================}
function PutRight ( S : string ; Ch : char ; Count : byte ) : string ;
begin
   PutRight                  := S + StrDup ( Ch , Count ) ;
end ;
   {===================================================================

   COPY - Start to Stop, versus Start & Quantity
          NOTE:  Returns blank on invalid index
   ===================================================================}
function CopyPos ( S : string ; Start , Stop : integer ) : string ;
begin
   CopyPos                   := '' ;
   if Stop >= Start then
      if Start > 0 then
         CopyPos             := Copy ( S ,
                                       Start ,
                                       Stop - Start + 1 ) ;
end ;
   {===================================================================

   DELETE - Start to Stop, versus Start & Quantity
            NOTE:  Return original on invalid index

   ===================================================================}
function DeletePos ( S : string ; Start , Stop : integer ) : string ;
begin
   if Stop >= Start then
      if Start > 0 then
         delete ( S , Start , Stop - Start + 1 ) ;
   DeletePos                 := S ;
end ;
   {===================================================================

   TRUNCATE - Delete from Index to end of string

   ===================================================================}
function Truncate ( Source : string ; Index : byte ) : string ;
begin
   Truncate                  := DeletePos ( Source ,
                                            Index ,
                                            length ( Source ) ) ;
end ;
   {===================================================================

   MATCH - return position, ignore case

   ===================================================================}
function Match ( SubStr , Target : string ) : integer ;
begin
   if length ( SubStr ) > 0 then
      Match                  := pos ( StrUpCase ( SubStr ) ,
                                      StrUpCase ( Target ) )
   else
      Match                  := 0 ;
end ;
   {===================================================================

   EXIST - if "SubStr" in "Target"; ignores case

   ===================================================================}
function StrExist ( SubStr , Target : string ) : boolean ;
begin
   StrExist                  := Match ( SubStr , Target ) > 0 ;
end ;
   {===================================================================

   COUNT - number of occurances

   ===================================================================}
function StrCount ( SubStr , S : string ) : integer ;
var
   x                         : integer ;
   Index                     : integer ;
begin
   x                         := 0 ;
   while TRUE do
   begin
      Index                  := Match ( SubStr , S ) ;
      if Index = 0 then
      begin
         StrCount            := x ;
         EXIT ;
      end ;
      inc ( x ) ;
      delete ( S , Index , Length ( SubStr ) ) ;
   end ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   TRIM

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   LEAD

   ===================================================================}
function TrimLeft ( Source , SubStr : string ) : string ;
begin
   SubStr                    := StrUpCase ( SubStr ) ;
   while pos ( SubStr , StrUpCase ( Source ) ) = 1 do
      delete ( Source , 1 , length ( SubStr ) ) ;
   TrimLeft                  := Source ;
end ;
   {===================================================================

   TRAIL - ignores case

   ===================================================================}
function TrimRight ( Source , SubStr : string ) : string ;
var
   Index                     : integer ;
   Temp                      : string ;
begin
   SubStr                    := StrUpCase ( SubStr ) ;
   while TRUE do
   begin
      Index                  := length ( Source ) - length ( SubStr ) + 1 ;
      temp                   := CopyPos ( Source ,
                                          Index ,
                                          length ( Source ) );

      if StrUpCase ( Temp ) <> SubStr then
      begin
         TrimRight           := Source ;
         EXIT ;
      end ;
      Source                 := DeletePos ( Source ,
                                            Index ,
                                            length ( Source ) ) ;
   end ;
end ;
   {===================================================================

   LEAD & TRAIL

   ===================================================================}
function Trim ( Source , SubStr : string ) : string ;
begin
   Source                    := TrimLeft ( Source , SubStr ) ;
   Source                    := TrimRight ( Source , SubStr ) ;
   Trim                      := Source ;
end ;
   {===================================================================

   PREFIX - remove first occurance of "SubStr"

   ===================================================================}
function TrimPrefix ( Source , SubStr : string ) : string ;
begin
   if Match ( SubStr , Source ) = 1 then
      delete ( Source , 1 , length ( SubStr ) ) ;
   TrimPrefix                := Source ;
end ;
   {===================================================================

   PLUCK - return word by index.  Guaranteed not to have whitespace.

   ===================================================================}
function Pluck ( S : string ; Index : byte ) : string ;
var
   count                     : byte ;
   Last                      : byte ;
   temp                      : string ;
begin
   Pluck                     := '' ;
   count                     := 0 ;
   temp                      := '' ;
   S                         := Trim ( S , #32 ) ;  { lead/trail whitespace }
   while TRUE do
   begin
      if count = Index  then
      begin
         Pluck               := temp ;
         EXIT ;
      end ;
      if S = '' then EXIT ;
      if pos ( #32 , S ) = 0 then
         Last                := length ( S )
      else
         Last                := pos ( #32 , S ) - 1 ;
      temp                   := copy ( S , 1 , Last ) ;
      delete ( S , 1 , Last ) ;
      S                      := TrimLeft ( S , #32 ) ; { delete whitespace }
      inc ( count ) ;
   end ;
end ;
   {===================================================================

   WORD COUNT - SubStrings separated by whitespace

   ===================================================================}
function WordCount ( S : string ) : byte ;
var
   count                     : byte ;
begin
   count                     := 0 ;
   S                         := Trim ( S , #32 ) ;      { delete whitespace }
   while TRUE do
   begin
      if S = '' then
      begin
         WordCount           := count ;
         EXIT ;
      end ;
      if pos ( #32 , S ) = 0 then
         S                   := ''
      else
         delete ( S , 1 , pos ( #32 , S ) - 1 ) ;
      S                      := TrimLeft ( S , #32 ) ; { delete whitespace }
      inc ( count ) ;
   end ;
end ;
  {===================================================================

  POS - Index of "Substr" in "Source", from "Start"; ignores case

  ===================================================================}
function PosNext ( Substr , Source : string ; Start : byte ) : byte ;
var
   found                     : boolean ;
   Index ,
   j ,
   Limit                     : byte ;
begin
   PosNext                   := 0 ;
   if Source = '' then EXIT ;
   if length ( SubStr ) = 0 then EXIT ;
   if length ( Source ) < length ( SubStr ) then EXIT ;
   Source                    := StrUpCase ( Source ) ;
   SubStr                    := StrUpCase ( SubStr ) ;
   Limit                     := length ( Source ) -
                                length ( SubStr ) +
                                1 ;
   if Start < 1 then
      Start                     := 1 ;
   for Index := Start to Limit do
   begin
      found                  := TRUE ;
      J                      := 0 ;
      Repeat
         inc ( j ) ;
         if Source [ Index + j - 1 ] <>
            SubStr [ j ] then
            found            := FALSE ;
      Until ( not found ) or
            ( j >= length ( SubStr ) ) ;
      if found then
      begin
         PosNext             := Index ;
         EXIT ;
      end ;
   end ;
end ;
   {===================================================================

   EXTRACT - From "SubStr" to whitespace or end; ignores case

   Source = 'hello kbNoKey there'
   SubStr = 'kb'

   Extract = 'kbNoKey'
   Source  = 'hello  there'

   ===================================================================}
function Extract ( SubStr : string ; VAR Source : string ) : string ;
var
   Start                     : integer ;
   Stop                      : integer ;
begin
   Extract                   := '' ;
   SubStr                    := Trim ( SubStr , #32 ) ;
   if length ( SubStr ) = 0 then EXIT ;
   Start                     := Match ( SubStr , Source ) ;
   if Start <> 1 then
   begin
      SubStr                 := #32 + SubStr ;
      Start                  := Match ( SubStr , Source ) ;
   end ;
   if Start = 0 then EXIT ;
   Stop                      := PosNext ( #32 , Source , Start + 1 ) - 1 ;
   if Stop < 1 then
      Stop                   := length ( Source ) ;
   SubStr                    := CopyPos ( Source ,
                                          Start ,
                                          Stop ) ;
   Extract                   := Trim ( SubStr , #32 ) ;
   Source                    := DeletePos ( Source , Start , Stop ) ;
end ;
   {===================================================================

   REPLACE - All occurances of Original with Replacement; ignores case

   ===================================================================}
function Replace ( Source , Original , Replacement : string ) : string ;
var
   Index ,
   L ,
   L2                        : byte ;
begin
   Index                     := PosNext ( Original , Source , 1 ) ;
   L                         := length ( Original ) ;
   L2                        := length ( Replacement ) ;
   while Index > 0 do
   begin
      Delete ( Source , Index , L ) ;                           { Cut }
      Insert ( Replacement , Source ,Index ) ;                { Paste }
      Index                  := Index +
                                1 -
                                L +
                                L2 ;
      Index                  := PosNext ( Original , Source , Index ) ;
   end ;
   Replace                   := Source ;
end ;
   {===================================================================

   REPLACECHAR - each CHAR in "CharSet" with "Replacement" string
   Note - case sensitive

   ===================================================================}
function ReplaceChar ( S , CharSet , Replacement : string ) : string ;
var
   i ,
   L                         : byte ;
   c                         : char ;
begin
   i                         := 1 ;
   L                         := length ( Replacement ) ;
   while i <= length ( S ) do
   begin
      C                      := S [ i ] ;
      if pos ( C , CharSet ) > 0 then
      begin
         delete ( S , i , 1 ) ;
         insert ( Replacement , S , i ) ;
         inc ( i , L ) ;
      end
      else
         inc ( i ) ;
   end ;
   ReplaceChar               := S ;
end ;
   {===================================================================

   FILL - replace WhiteSpace with "FillChar" between SearchChars

   ===================================================================}
function FillBetween ( S : string ; SearchCh , FillCh : char ) : string ;
var
   x                         : byte ;
   Found                     : boolean ;
begin
   Found                     := FALSE ;
   for x := 1 to length ( S ) do
   begin
      if Found then
      begin
         if S [ x ] = SearchCh then
            Found            := FALSE
         else
            if S [ x ] = #32 then
               S [ x ]       := FillCh ;
      end
      else
         if S [ x ] = SearchCh then
            Found            := TRUE ;
   end ;
   FillBetween               := S ;
end ;
   {===================================================================

   COUNT CHAR - number of occurances of "Ch" in "S"

   ===================================================================}
function CountCh ( Ch : char ; S : string ) : byte ;
var
   count                     : byte ;
begin
   count                     := 0 ;
   while pos ( Ch , S ) > 0 do
   begin
      inc ( count ) ;
      delete ( S , pos ( Ch , S ) , 1 ) ;
   end ;
   CountCh                 := count ;
end ;
   {===================================================================

   WIDE SPACE - Left/Right Justify, Center & Fill-Between by replacing
   "^W" chars with spaces until desired width is reached.

   ^W+"Hello"      --> "         Hello"
   "Hello"+^W      --> "Hello         "
   ^W+"Hello"+^W   --> "     Hello    "
   "Hi"+^W+"There" --> "Hi       There"

   ===================================================================}
function WideSpace ( S : string ; Code : Char ; NewWidth : byte ) : string ;
var
   Wcount ,
   index                     : byte ;
   {-------------------------------------------------------------------
   -------------------------------------------------------------------}
procedure Run ;
begin
   while TRUE do
   begin
      if length ( S ) >= NewWidth then EXIT ;
      index                  := 1 ;
      while index <= length ( S ) do
      begin
         if length ( S ) >= NewWidth then EXIT ;
         if S [ index ] = Code then
         begin
            insert ( #32 , S , index ) ;
            inc ( index ) ;
         end ;
         inc ( index ) ;
      end ;
   end ;
end ;
   {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
begin
   WideSpace                 := S ;
   Wcount                    := CountCh ( Code , S ) ;
   if Wcount = 0 then EXIT ;
   NewWidth                  := NewWidth + Wcount ;
   Run ;
   while pos ( Code , S ) > 0 do
      delete ( S , pos ( Code , S ) , 1 ) ;
   WideSpace                 := S ;
end ;
   {===================================================================

   IBM Graphics/Line-Draw to ASCII

   ===================================================================}
procedure ConvertLineDraw ( VAR Ch : char ) ;
begin
   if Ord ( Ch ) and $0080 = 0 then EXIT ;
   case Ch of
   {-------------------------------------------------------------------
   CORNERS
   -------------------------------------------------------------------}
   '⌐' , '¬' , '╖' , '╕' , '╗', '╝' , '╜' , '╛' , '┐', '└' , '╚' , '╔' ,
   '╙' , '╘' , '╒' , '╓' , '┘' , '┌' : Ch := '+' ;
   {-------------------------------------------------------------------
   INTERSECTIONS
   -------------------------------------------------------------------}
   '┴' , '┬' , '├' , '┼' , '╞' , '╟' , '╩' , '╦' , '╠' , '╬' , '╧' ,
   '╨' , '╤' , '╥' , '╫' , '╪' : Ch := '#' ;
   {-------------------------------------------------------------------
   VERTICAL
   -------------------------------------------------------------------}
   '│' , '║' : Ch := '|' ;
   {-------------------------------------------------------------------
   HORIZONTAL
   -------------------------------------------------------------------}
   '─' , '═' : Ch := '-' ;
   {-------------------------------------------------------------------
   BLOCK
   -------------------------------------------------------------------}
   '░' , '▒' , '▓' , '█' , '▄' , '▌' ,'▐' , '▀' , '■' : Ch := '*' ;
   else
      Ch                     := #32 ;
   end ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

                  *** PARAM, SWITCHES & FILENAMES ***

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   Everything from DOS command-line in upper case

   ===================================================================}
function CommandLineString : string ;
var
   S                         : string ;
   x                         : byte ;
begin
   S                         := ParamStr ( 1 ) ;
   for x := 2 to ParamCount do
      S                      := S + #32 + ParamStr ( x ) ;
   CommandLineString         := StrUpCase ( S ) ;
end ;
   {===================================================================

   PARAM - Just params; ie:  C:>prg "filespec ok /a/b/c" --> "FILESPEC OK"

   ===================================================================}
function ParameterString : string ;
begin
   ParameterString           := DeletePos ( CommandLineString ,
                                            pos ( '/' , CommandLineString ) ,
                                            length ( CommandLineString ) ) ;
end ;
   {===================================================================

   SWITCH - return switches separated by whitespace
            ie:  C:>prg "filespec ok /a/b/c" --> "/A /B /C"

   ===================================================================}
function SwitchString : string ;
var
   S                         : string ;
begin
   S                         := CopyPos ( CommandLineString ,
                                          pos ( '/' , CommandLineString ) ,
                                          length ( CommandLineString ) ) ;
   S                         := Replace ( S , '/' , ' /' ) ;
   SwitchString              := S ;
end ;
   {===================================================================

   SWITCH - Return TRUE if "/a" or "a" in C:>prg "filespec ok /a/b/c"

   ===================================================================}
function IsSwitch ( S : string ) : boolean ;
var
   Switches                  : string ;
   x                         : byte ;
begin
   IsSwitch                  := TRUE ;
   S                         := StrUpCase ( Replace ( S , '/' , '' ) ) ;
   Switches                  := StrUpCase ( Replace ( SwitchString ,
                                                      '/' ,
                                                      #32 ) ) ;
   for x := 1 to WordCount ( Switches ) do
      if S = Pluck ( Switches , x ) then EXIT ;
   IsSwitch                  := FALSE ;
end ;
   {===================================================================

   PARAM - Return TRUE if "OK" or "ok" in  C:>prg "filespec ok /a/b/c"

   ===================================================================}
function IsParam ( S : string ) : boolean ;
var
   Params                    : string ;
   x                         : byte ;
begin
   IsParam                   := TRUE ;
   Params                    := StrUpCase ( Replace ( ParameterString ,
                                                      '/' ,
                                                      #32 ) ) ;
   for x := 1 to WordCount ( Params ) do
      if S = Pluck ( Params , x ) then EXIT ;
   IsParam                   := FALSE ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   NAME

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   DIR - replace directory.  Returns fully-qualified FileSpec.

   ===================================================================}
function ReplaceDir ( FileSpec , Dir : string ) : string ;
var
   D                         : DirStr ;
   N                         : NameStr ;
   E                         : ExtStr ;
begin
   ReplaceDir                := '' ;
   FileSpec                  := FExpand ( FileSpec ) ;
   FSplit ( FileSpec , D , N , E ) ;
   if pos ( '.' , E ) = 0 then
      E                      := '.' + E ;
   if Dir [ length ( Dir ) ] <> '\' then
      Dir                    := Dir + '\' ;
   ReplaceDir                := Dir + N + E ;
end ;
   {===================================================================

   NAME - replace just name; wildcard if blank

   ===================================================================}
function ReplaceName ( FileSpec , Name : string ) : string ;
var
   D                         : DirStr ;
   N                         : NameStr ;
   E                         : ExtStr ;
begin
   ReplaceName               := '' ;
   FSplit ( FileSpec , D , N , E ) ;
   if N = '' then
      N                      := '*' ;
   if pos ( '.' , E ) = 0 then
      E                      := '.' + E ;
   ReplaceName               := D + Name + E ;
end ;
   {===================================================================

   EXTENSION - replace if blank or Forced

   ===================================================================}
function ReplaceExt ( FileSpec , Ext : string ; Force : boolean ) : string ;
var
   D                         : DirStr ;
   N                         : NameStr ;
   E                         : ExtStr ;
begin
   ReplaceExt                := '' ;
   FileSpec                  := FExpand ( FileSpec ) ;
   FSplit ( FileSpec , D , N , E ) ;
   if N = '' then EXIT ;                                     { blank! }
   if Force or ( E = '' ) then
   begin
      if Ext <> '' then
         if pos ( '.' , Ext ) = 0 then
            Ext              := '.' + Ext ;
      ReplaceExt             := D + N + Ext ;
   end
   else
      ReplaceExt             := FileSpec ;
end ;
   {===================================================================

   DIRECTORY - just the drive & directory.

   ===================================================================}
function DriveDir ( FileSpec : string ) : string ;
var
   D                         : DirStr ;
   N                         : NameStr ;
   E                         : ExtStr ;
begin
   FileSpec                  := FExpand ( FileSpec ) ;
   FSplit ( FileSpec , D , N , E ) ;
   DriveDir                  := D ;
end ;
   {===================================================================

   NAME

   ===================================================================}
function NameOnly ( FileSpec : string ) : string ;
var
   D                         : DirStr ;
   N                         : NameStr ;
   E                         : ExtStr ;
begin
   FileSpec                  := FExpand ( FileSpec ) ;
   FSplit ( FileSpec , D , N , E ) ;
   NameOnly                  := N ;
end ;
   {===================================================================

   EXTENSION

   ===================================================================}
function ExtOnly ( FileSpec : string ) : string ;
var
   D                         : DirStr ;
   N                         : NameStr ;
   E                         : ExtStr ;
begin
   FileSpec                  := FExpand ( FileSpec ) ;
   FSplit ( FileSpec , D , N , E ) ;
   ExtOnly                   := E ;
end ;
   {===================================================================

   NAME & EXTENSION

   ===================================================================}
function NameExt ( FileSpec : string ) : string ;
var
   D                         : DirStr ;
   N                         : NameStr ;
   E                         : ExtStr ;
begin
   FileSpec                  := FExpand ( FileSpec ) ;
   FSplit ( FileSpec , D , N , E ) ;
   NameExt                   := N + E ;
end ;
   {===================================================================

   DRIVE DIR - Uses FExpand to determine current directory

   ===================================================================}
function DirOfDrive ( B : byte ) : string ;
begin
   if B > 26 then
      B                      := 0 ;
   if B = 0 then
      DirOfDrive             := FExpand ( '' )
   else
      DirOfDrive             := FExpand ( Chr ( B + 64 ) + ':' ) ;
end ;
   {===================================================================

   CALC - find "FileName" in "Path" or "GetEnv('PATH')"

   ===================================================================}
function CalcName ( FileName , Path : PathStr ) : PathStr ;
var
   Dir                       : DirStr ;
   Name                      : NameStr ;
   Ext                       : ExtStr ;
begin
   CalcName                  := '' ;
   FileName                  := FExpand ( FileName ) ;
   {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   DIR - In current or given
   - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
   if FileExist ( FileName ) then
   begin
      CalcName               := FileName ;
      EXIT ;
   end ;
   {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   DIR - On specified "Path"
   - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
   FSplit ( FileName , Dir , Name , Ext ) ;
   FileName                  := Name + Ext ;
   FileName                  := FSearch ( FileName , Path ) ;
   if FileName <> '' then
   begin
      CalcName               := FExpand ( FileName ) ;
      EXIT ;
   end ;
   {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   DIR - Environment "PATH"
   - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
   FileName                  := Name + Ext ;
   FileName                  := FSearch ( FileName , GetEnv ( 'PATH' ) ) ;
   if FileName <> '' then
   begin
      CalcName               := FExpand ( FileName ) ;
      EXIT ;
   end ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   FILE

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   FILE EXIST

   ===================================================================}
function FileExist ( Path : string ) : boolean ;
var
   SR                        : SearchRec ;
begin
   FileExist                 := FALSE ;                         { set }
   if Path = '' then EXIT ;                           { NUL not valid }
   if pos ( '?' , Path ) > 0 then EXIT ;         { wildcard not valid }
   if pos ( '*' , Path ) > 0 then EXIT ;         { wildcard not valid }
   FindFirst ( Path , 0 , SR ) ;                            { ask DOS }
   FileExist                 := DosError = 0 ;               { result }
end ;
   {===================================================================

   EXISTDIR - Return TRUE if the directory exists

   ===================================================================}
function DirExist ( DirName : string ) : boolean ;
var
   OldDosError               : integer ;
   SR                        : SearchRec ;
begin
   DirExist                  := FALSE ;
   if pos ( '?' , DirName ) > 0 then EXIT ;
   if pos ( '*' , DirName ) > 0 then EXIT ;
   OldDosError               := DosError ;
   if DirName [ length ( DirName ) ] <> '\' then
      DirName                := DirName + '\' ;
   DirName                   := FExpand ( DirName ) ;
   FindFirst ( DirName + '*.*' , AnyFile , SR ) ;
   DirExist                  := ( DosError = 0 ) and
                                (
                                  ( SR.Attr and Directory <> 0 ) or
                                  ( length ( DirName ) = 3 )   { root }
                                ) ;
   DosError                  := OldDosError ;
end ;
   {===================================================================

   ERASE

   ===================================================================}
function FileErase ( S : string ) : boolean ;
var
   F                         : File ;
begin
{$I-}
   Assign ( F , S ) ;
   Erase ( F ) ;
{$I+}
   FileErase                 := IOresult = 0 ;
end ;
   {===================================================================

   RENAME

   ===================================================================}
function FileRename ( OldName , NewName : string ) : boolean ;
var
   Ftemp                     : File ;
begin
   SYSTEM.Assign ( Ftemp , OldName ) ;
{$I-}
   SYSTEM.Rename ( Ftemp , NewName ) ;
{$I+}
   FileRename                := IOresult = 0 ;
end ;
   {===================================================================

   EXIST:  Match case sensitive KeyString in *.REZ file.

   ===================================================================}
function RezExist ( KeyString , FileName : string ) : boolean ;
var
   RezFile                   : PResourceFile ;
   RezStream                 : PStream ;
   i                         : integer ;
begin
   RezExist                  := FALSE ;                   { assume no }
   if not FileExist ( FileName ) then EXIT ;                { no file }
   RezStream                 := New ( PDosStream ,
                                      Init ( FileName ,
                                             stOpen ) ) ;  { instance }
   RezFile                   := New ( PResourceFile ) ;        { init }
   RezFile^.Init ( RezStream ) ;                               { init }
   if RezStream^.Status <> stOK then EXIT ;                { problem! }
   with RezFile^ do
      for i := 0 to Count - 1 do
      begin
         if KeyString = KeyAt ( i ) then
         begin
            RezExist         := TRUE ;                       { gotcha }
            Dispose ( RezFile , Done ) ;      { dumps "RezStream" too }
            EXIT ;                                             { done }
         end ;
      end ;
   Dispose ( RezFile , Done ) ;               { dumps "RezStream" too }
end ;
   {===================================================================

   GET NAME - return name within width; remove DRIVE:\DIR if same as
   current dir.

   filename.ext     C:\..\filename.ext  D:\filename.ext
   123456789012     123456789012345678  12345678901234
   12               18                  15
   ===================================================================}
function GetName ( S : PathStr ; MaxSize : byte ) : string ;
var
   Dir                       : DirStr ;
   Name                      : NameStr ;
   Ext                       : ExtStr ;
   Current                   : DirStr ;
begin
   S                         := FExpand ( S ) ;
   FSplit ( S , Dir , Name , Ext ) ;
   Current                   := FExpand ( '' ) ;
   if Dir = Current then
   begin
      GetName                := Name + Ext ;            { current dir }
      EXIT
   end ;
   if Dir [ 1 ] = Current [ 1 ] then
      delete ( Dir , 1 , 2 ) ;                            { dump "x:" }
   if length ( Dir + Name + Ext ) > MaxSize then
      if length ( Dir ) > 3 then
         Dir                 := '\..\' ;
   S                         := Dir + Name + Ext ;
   while length ( S ) > MaxSize do                         { failsafe }
      delete ( S , 1 , 1 ) ;
   GetName                   := S ;
end ;